home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / System source / Window < prev   
Text File  |  1994-06-24  |  9KB  |  293 lines
  1. \  5/07/84  NDI Version 1
  2. \  9/05/84  CBD Version 1.3
  3. \  9/07/84  CBD Fixed GetVRect:
  4. \ 11/22/84  cbd ctlHit, fixed drag:, grow:
  5. \ 12/08/85  cdn Modified enable: & disable: to flip-flop Null-Evt vectors
  6. \ 12/15/85  cdn Moved FinalSave to Util module
  7. \  4/15/86    cdn    Added Hide: method
  8. \  5/27/86  cdn Added idle vector; enable:/disable now set actW (active window)
  9. \  8/07/86  cdn Added deact vector & setact:
  10. \  8/12/86  cdn Removed extraneous drops in new:
  11. \ 12/26/87    rfl    could modify draw: to not set, but to set super to save fprect
  12. \ 11/06/90    rfl    example: now uses grayRgn for drag; simplified classinit
  13. \ 11/23/90    rfl    added grayRgn word
  14. \  3/22/91    rfl    because of complaints, growbox now erased on grow
  15. \  4/09/91    rfl    also, grow now computes to send next line to bottom if necessary
  16. \  4/29/91    rfl simplified eraseGrow:...but did not recompile source
  17. \ 10/21/91    rfl    added a lot of Michael Hore's window routines, grow box support, etc.
  18. \                moved screenbits from objinit
  19. \ 12/18/91    rfl    resID now stored with object, getnew: requires nothing on stack
  20. \ 12/27/91    rfl    drag no longer selects window...command key option works as in IM
  21. \  6/22/92    rfl    erasegrow: only works if grow flag is set
  22. \  9/28/92    rfl    added portBit:
  23. \ 10/18/92    rfl added 'part' as parameter for zoom handler...Used to have to use
  24. \                 mp2 to get zoom state from methods stack
  25. \  5/10/93    rfl    shortened getnew: and check for resource with error message
  26. \  5/29/93    rfl removed theWindow; changed thePort to myPort.
  27. \  1/03/94    rfl    added cut, copy and paste methods
  28. Decimal
  29.  
  30.  -1  Constant  inFront
  31.   0  Variable  myPort
  32. 129  Constant  Thumb
  33.  
  34.   0  Constant  docWind
  35.  16  Constant  rndWind
  36.   1  Constant  dlgWind
  37.  
  38. : initFont  9 tsize 4 tfont 0 tMode 0 tFace  ;
  39. : grayRgn ( -- l t r b ) $ 9ee -base @ >ptr 2+ get: rect ;
  40.  
  41. \ ( b -- bool )  make a Forth boolean into a Toolbox boolean
  42. : Bool   8 << makeInt  ;
  43.  
  44. \ save and restore the GrafPort
  45. : savePort   myPort +base call GetPort ;
  46. : restPort   myPort @  call SetPort ;
  47.  
  48. \ ( -- l t r b )  leave dimension coordinates of host machine's display
  49. : ScreenBits
  50.     $ 904 -base @ -base @ -base 116 -
  51.     dup    @ unpack
  52.     rot 4+ @ unpack
  53. ;
  54.  
  55. \ define the basic Window class, which has no controls
  56. :CLASS Window  <Super GrafPort
  57.  
  58.     $ 20 Bytes    wind1    \ unmapped
  59.     Handle        Ctllist    \ 1st ctl
  60.     $ 0C Bytes    wind2    \ unmapped
  61.  
  62.     Rect    contRect    \ true content
  63.     Rect    growRect    \ grow size rectangle
  64.     Rect    dragRect    \ Drag limits rect
  65.     Int        growFlg        \ true if growable
  66.     Int        dragFlg        \ true if draggable
  67.     Int        Alive        \ true if space exists
  68.     Var        Idle        \ cfa- idle handler
  69.     Var        Deact        \ cfa- deactivate event handler
  70.  
  71.     Var        Content        \ cfa- content handler
  72.     Var        Draw        \ cfa- draw handler
  73.     Var        Enact        \ cfa- activate event handler
  74.     Var        Close        \ cfa- close handler
  75.     Int        Resid        \ Resource ID
  76.     int        scrollFlg    \ flag to not update fprect for scrolling
  77.     Var        Zoom        \ cfa- zoom word
  78.  
  79. \ set drag and grow limits based on multiple screen regions
  80.     :M  SETLIMITS: grayRgn put: dragRect
  81.         40 40 getBot: dragRect put: growRect
  82.         4 4 inset: dragRect true put: dragFlg true put: growFlg ;M
  83.  
  84.     :M  SETZOOM: put: Zoom ;M
  85.  
  86.     :M  SETSCROLL: put: scrollFlg ;M
  87.  
  88.     :M  SETFPRECT: get: scrollFlg IF get: contRect put: fPrect THEN ;M
  89.  
  90.     \ ( -- )  update the Forth output, scrolling rects
  91.     :M  SETVIEW: get: portRect get: growFlg
  92.         IF swap 15 - swap 15 - THEN  put: contRect
  93.         setfPrect: self ;M
  94.  
  95.     \ ( n --)
  96.     :M  PUTRESID: put: resID ;M
  97.     \ ( -- )
  98.     :M  CLOSE:  get: alive
  99.         IF (abs) call CloseWindow clear: alive  exec: close
  100.         THEN  ;M
  101.  
  102.     \ ( -- )  Make this wind the current GrafPort
  103.     :M  SET:  set: super setfPrect: self ;M
  104.  
  105.     :M  PORTBIT: ( -- abs) (abs) 2+ ;M
  106.  
  107.     \ update window with its entire port rectangle as the update region.
  108.     :M  UPDATE: pushPort set: self
  109.         getRect: self  put: tempRect  update: tempRect
  110.         popPort ;M
  111.  
  112.     :M InitNewWindow: setView: [ ^base ]
  113.         set: self initFont true put: alive cls ;M
  114.  
  115.     :M PenIntoWind: @xy bottom min gotoxy ;M
  116.  
  117.     \ Define a new window on heap with specified features
  118.     :M  NEW:  { bndsRect tAddr tLen procID vis goAway -- }
  119.         Get: Alive  0=
  120.         IF    0 (abs)  bndsrect +base  taddr tlen str255 vis bool
  121.             procID  makeInt inFront  goAway bool  0
  122.             call NewWindow drop   initNewWindow: self
  123.         THEN  ;M
  124.  
  125.     \ ( -- )  new window from resource file
  126.     :M  GETNEW:   get: alive  0=
  127.         IF  0 int: resid (abs) infront
  128.             call GetNewWindow 0= classerr" 170
  129.             initNewWindow: self select: [ ^base ] 
  130.         ELSE drop
  131.     THEN   ;M
  132.  
  133.     \ ( -- l t r b )  Return the vert. scroll bar rect
  134.     :M  GETVRECT:  GetBotx: portRect  15 -
  135.         GetTopy: portRect 1- getBotX: portRect 1+
  136.         getBotY: portRect 14 - ;M
  137.  
  138.     \ ( -- l t r b )  Return the horizontal scroll bar rect
  139.     :M  GETHRECT: getTopX: portRect 1- getBotY: portRect 15 -
  140.         getBotX: portRect 14 - getBotY: portRect 1+ ;M
  141.  
  142.     \ ( -- )  update content area
  143.     :M  DRAW:    get: fPrect
  144.         (abs) call BeginUpdate
  145.         savePort @xy set: self
  146.         get: growFlg
  147.         IF    @xy (abs)  call DrawGrowIcon
  148.             gotoxy
  149.         THEN
  150.         exec: draw   restport gotoxy    \ call user draw routine
  151.         (abs) call EndUpdate 
  152.         put: fPrect  ;M
  153.  
  154.     \ ( -- )  Make this the front window
  155.     :M  SELECT:   (abs)  call SelectWindow setfPrect: self ;M
  156.  
  157.     \ The idle: method is normally called, (after executing the system tasks),
  158.     \ for the front-most window, whenever a null event occurs. It should be a
  159.     \ window-specific task.  NULL-EVT is the normal word which sends idle:
  160.     :M  IDLE:    exec: idle ;M
  161.  
  162.     \ ( cfa -- )  Install a null event handler for this window
  163.     :M  SETIDLE: put: idle  ;M
  164.  
  165.     \ ( -- )  response to activate event
  166.     :M  ENABLE:  ^base -> actW                \ commence idle handler
  167.         set: self
  168.         get: growFlg IF @xy (abs) call DrawGrowIcon gotoxy THEN
  169.         exec: Enact  ;M
  170.  
  171.     \ ( -- )  response to deactivate event
  172.     :M  DISABLE: 0 -> actW
  173.         get: growFlg
  174.         IF @xy (abs) call DrawGrowIcon gotoxy THEN
  175.         exec: deact ;M   \ cease idle handler
  176.  
  177.     \ ( enact deact -- )  Set the activate/deactivate event handlers
  178.     :M  SETACT:  put: Deact put: Enact  ;M
  179.  
  180.     \ ( -- b )  is this window active ?
  181.     :M  ACTIVE:  0 call FrontWindow (abs)  =    ;M
  182.  
  183.     \ ( -- b )  is this window alive?
  184.     :M  ALIVE:   get: alive   ;M
  185.  
  186.     \ ( -- )  response to drag region click
  187.     :M  DRAG:  get: dragFlg
  188.         IF (abs)  Where: fEvent  abs: dragRect
  189.             call DragWindow
  190.         THEN  ;M
  191.  
  192.     :M ERASEGROW: get: growFlg
  193.         IF  getVRect: self 16 + put: tempRect
  194.             clear: tempRect update: tempRect
  195.             getHRect: self put: temprect clear: temprect  update: tempRect
  196.         THEN ;M
  197.  
  198.     :M FIXGROW: eraseGrow: self setView: [ ^base ] penIntoWind: self ;M
  199.  
  200.     \ ( w h -- )  reSize window and accumulate update regions
  201.     :M  SIZE:    pack  (abs)  swap  True makeInt
  202.         eraseGrow: self
  203.         call SizeWindow    \ resize the window
  204.         fixGrow: self    ;M
  205.  
  206.     :M  ZOOM: { part -- } word0 (abs) where: fEvent
  207.         part makeint call TrackBox i->l
  208.         IF     eraseGrow: self get: zoom
  209.             IF   part 7 - exec: zoom                        \ execute special zoom
  210.             ELSE (abs) part makeint word0 call zoomWindow    \ default zoom
  211.             THEN
  212.             fixGrow: self
  213.         THEN ;M
  214.  
  215.     \ ( -- )  response to grow region click
  216.     :M  GROW:  Get: growFlg
  217.         IF  0 (abs) Where: fEvent  abs: growrect
  218.             call GrowWindow  -dup
  219.             IF  unpack size: self draw: self
  220.                 penIntoWind: self    \ go to new bottom
  221.             THEN
  222.         THEN  (abs) call SelectWindow ;M
  223.  
  224.     \ ( -- )  Handle a content click
  225.     :M  CONTENT:  Active: self
  226.         IF    exec: content    \ call the content handler
  227.         ELSE  (abs) call SelectWindow THEN  ;M
  228.  
  229.     \ ( close enact draw cont -- )  init window  event handler words
  230.     :M  ACTIONS:   put: content  put: draw  put: enact
  231.         put: close  ;M
  232.  
  233.     \ ( addr len -- )
  234.     :M  TITLE:   str255 (abs) swap  call SetWTitle  ;M
  235.  
  236.     \ ( addr len -- )  Name: is for string class compatibility
  237.     :M  NAME:  title: self  ;M
  238.  
  239.     \ ( -- addr len )  return name of window
  240.     :M  GETNAME:  (abs)  buf255 +base call GetWTitle
  241.         buf255 count   ;M
  242.  
  243.     \ ( x y -- )
  244.     :M  MOVETO:   Pack (abs) swap false makeInt
  245.         call MoveWindow   ;M
  246.  
  247.     :M  CENTER: { \ sw sh pw ph -- }
  248.         screenBits -> sh -> sw 2drop
  249.         size: portRect -> ph -> pw
  250.         sw pw - 2/  sh ph - 2/  moveto: self ;M
  251.         
  252.  
  253.     :M  CUT:   null ;M
  254.     :M  COPY:  null ;M
  255.     :M  PASTE: null ;M
  256.     :M  CLEAR: null ;M
  257.  
  258.     \ ( chr -- )  just drop keys
  259.     :M  KEY:   drop ;M
  260.  
  261.     \ ( -- )   Make this window visible
  262.     :M  SHOW:   (abs)  call ShowWindow ;M
  263.  
  264.     \ ( -- )   Make this window visible
  265.     :M  HIDE:   (abs)  call HideWindow ;M
  266.  
  267.     \ ( l t r b  t OR f -- )  set grow limits
  268.     :M  SETGROW:    DUP put: GrowFlg
  269.         IF  put: growrect THEN ;M
  270.  
  271.     \ ( l t r b  t OR f -- )  Set drag limits
  272.     :M  SETDRAG:  dup  Put: dragFlg
  273.         IF Put: dragRect THEN  ;M
  274.  
  275.     \ ( cfa -- )  set the draw handler
  276.     :M  SETDRAW:  put: draw  ;M
  277.  
  278.     :M  CLASSINIT:
  279.         <[ 4 ]> 'cfas  null null null null actions: self
  280.         'c null put: idle
  281.         'c null put: deact
  282.     ;M
  283.  
  284.     \ ( -- )  show an example of Window; use grayRgn for drag limits
  285.     :M EXAMPLE:  100 100 300 200 put: tempRect    \ set size of window
  286.         tempRect  " Example"
  287.         docWind  true true  new: self
  288.         grayRgn true setDrag: self  ;M
  289.  
  290. ;CLASS
  291.  
  292. ' Window 'c fWind !
  293.